type binop =
    Plus
  | Minus
  | Times
  | Div
  | Mod
  | Le
  | Leq
  | Ge
  | Geq
  | Eq
  | Neq
  | And
  | Or

type uop = Uminus | Neg

type mptype = Integer | Boolean | Void | Record of string | Pointer

type expr =
    T
  | F
  | Int of int
  | Var of string
  | Binexpr of binop * expr * expr
  | Unexpr of uop * expr
  | Call of string * expr list
  | Field of string * expr * string
  | Nil of mptype

type stat =
    Assign of expr * expr
  | If1 of expr * stat
  | If2 of expr * stat * stat	
  | While of expr * stat
  | Seq of stat list
  | Expr of expr
  | New of expr * mptype


type typing = string * mptype

type mpsort = mptype list * mptype

type sorting = string * mpsort

type sortings = sorting list

type decl = typing list

class type mprecord_t =
object
	method name : string
	method members : decl	
end

class type mpfun_t =
object
  method name : string
  method parms : decl
  method locals : decl
  method body : stat
  method rettype : mptype
  method print : unit
end

class type mpprog_t =
object
  method vars : decl
	method recorddecls : mprecord_t list
  method fundecls : sortings
  method funs : mpfun_t list
  method body : stat
  method print : unit
end

(* ---------------------------------------------------------------------------*)

(* Printing: *)

let indent_string = "    " 
;;

let print_indent d =
    for i = 1 to d do
      print_string indent_string
    done
;;

let print_at_depth dp str = 
  print_indent dp;
  print_string str
;;

let print_endline_at_depth dp str =
  print_indent dp;
  print_endline str
;;  

let print_list l print sep =
  let rec do_print_list = function
    | [] ->
	()
    | [x] ->
	print x
    | h::t ->
	print h;
	print_string sep;
	do_print_list t
  in 
 do_print_list l
;;

(* ---------------------------------------------------------------------------*)

let print_binop = function
  | Plus ->
      print_string "Plus"
  | Minus ->
      print_string "Minus"
  | Times ->
      print_string "Times"
  | Div ->
      print_string "Div"
  | Mod ->
      print_string "Mod"
  | Le ->
      print_string "Le"
  | Leq ->
      print_string "Leq"
  | Ge ->
      print_string "Ge"
  | Geq ->
      print_string "Geq"
  | Eq ->
      print_string "Eq"
  | Neq ->
      print_string "Neq"
  | And ->
      print_string "And"
  | Or ->
      print_string "Or"
;;

let print_uop = function
  | Uminus ->
      print_string "Uminus"
  | Neg ->
      print_string "Neg"
;;
  
let rec print_expr depth expr = 
  print_newline ();
  match expr with
    | T ->
	print_at_depth depth "(T)"
    | F ->
	print_at_depth depth "(F)"
    | Int  x ->
	print_at_depth depth ("(Int "^(string_of_int x)^")")
    | Var  s ->
	print_at_depth depth ("(Var "^s^")")
    | Binexpr  (op, e1, e2) ->
	print_binexpr depth op e1 e2
    | Unexpr (op, e) ->
	print_uexpr depth op e
    | Call (s,el) ->
	print_call depth s el
    | Field(name, expr, rname) ->
        print_at_depth depth ("Field "^name);
        print_expr (depth+1) expr
    | Nil mptype ->
        print_at_depth depth "(Nil)"
and print_binexpr depth op e1 e2 =
  print_at_depth depth "Binexpr ";
  print_binop op;
  print_expr (depth+1) e1;
  print_expr (depth+1) e2;
and print_uexpr depth op e =
  print_at_depth depth "Uexpr ";
  print_uop op;
  print_expr (depth+1) e;
and print_call depth s el =
  print_at_depth depth ("Call "^s);
  List.iter (print_expr (depth+1)) el; 
;;

let rec print_stat depth st = 
  print_newline ();
  match st with
    | Assign (v,e) ->
	print_at_depth depth ("Assign");
        print_expr (depth+1) v;
        print_expr (depth+1) e
    | If1 (e,s) ->
	print_if1 depth e s
    | If2 (e,s1,s2) ->
	print_if2 depth e s1 s2
    | While (e,s) ->
	print_while depth e s
    | Seq sl ->
	List.iter (print_stat depth) sl
    | Expr e ->
        print_at_depth depth "Expr";
        print_expr (depth+1) e
    | New (expr, et) ->
        print_at_depth depth "New";
        print_expr (depth+1) expr
and print_if1 depth  e s =
  print_at_depth depth "If1";
  print_expr (depth+1) e;
  print_stat (depth+1) s
and print_if2 depth e s1 s2 =
  print_at_depth depth "If2";
  print_expr (depth+1) e;
  print_stat (depth+1) s1;
  print_stat (depth+1) s2
and print_while depth e s =
  print_at_depth depth "While";
  print_expr (depth+1) e;
  print_stat (depth+1) s
;;

(* ---------------------------------------------------------------------------*)

let print_type = function
  | Integer ->
      print_string "Int"
  | Boolean ->
      print_string "Bool"
  | Void ->
      print_string "Void"
  | Record string ->
      print_string "Record"
  | Pointer ->
      print_string "Pointer"
;;

let print_var (v,t) = 
  print_string (v^": ");
  print_type t;
;;

let print_vars vl =  
  print_list vl print_var ", "
;;

let print_sort args ret =
  print_list args print_type ",";
  print_string " -> ";
  print_type ret
;;

let print_fundecl (fname,(args,ret)) =
  print_string ("Forward: "^fname^"(");
  print_list args print_type ",";
  print_string ") -> ";
  print_type ret


let print_fundecls dl =
  print_list dl print_fundecl "\n"
;;


(* ---------------------------------------------------------------------------*)

class mprecord n m : mprecord_t =
object
	val name = n;
	val members = m;
	method name = name;
	method members = members;
end

let new_mprecord n m = new mprecord n m
;;

class mpfun n p l b r : mpfun_t =
object
  val name = n;
  val parms = p; 
  val locals = l;
  val body = b;
  val rettype = r;
  method name = name;
  method parms = parms;
  method locals =  locals;
  method body = body;
  method rettype = rettype;
  method print =
    print_string "\n======================================\n";
    print_string ("Function "^name^": ");
    print_sort (List.map snd parms) rettype;
    print_string "\nParameters: ";
    print_vars parms; 
    print_string "\nLocal variables: ";
    print_vars locals;
    print_string "\n";
    print_stat 0 body;
    print_string "\n"
end

let new_mpfun n p l b r = new mpfun n p l b r
;;

class mpprog v r d f b : mpprog_t =
object
  val vars = v;
	val recorddecls = r;
  val fundecls = d;
  val funs = f;
  val body = b;
  method vars = vars;
	method recorddecls = recorddecls;
  method fundecls = fundecls;
  method funs = funs;
  method body = body;
  method print =
    print_string "\n\n++++++++++++++++++++++++++++++++++++++\n\n";
    print_vars vars;
		print_string "\n\n++++++++++++++++++++++++++++++++++++++\n\n";
		(* print_recorddecls recorddecls; *) (* no record printing :( *)
    print_string "\n\n++++++++++++++++++++++++++++++++++++++\n";
    print_fundecls fundecls;
    print_string "\n\n++++++++++++++++++++++++++++++++++++++\n";
    List.iter (fun f -> f#print) funs;
    print_string "\n++++++++++++++++++++++++++++++++++++++";
    print_stat 0 body;
    print_string "\n\n++++++++++++++++++++++++++++++++++++++\n\n"
end

let new_mpprog v r d f b = new mpprog v r d f b
;;
